home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / rt / mc68881.lisp < prev    next >
Encoding:
Text File  |  1992-03-10  |  19.0 KB  |  565 lines
  1. ;;; -*- Package: RT -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: mc68881.lisp,v 1.11 92/03/09 20:37:46 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; The following code is to support the MC68881 floating point chip on the APC
  15. ;;; card.  Adapted by Rob MacLachlan from the Sparc support, written by Rob
  16. ;;; MacLachlan and William Lott, with some stuff from Dave McDonald's original
  17. ;;; RT miscops.
  18. ;;;
  19. (in-package "RT")
  20.  
  21. (eval-when (compile eval load)
  22.  
  23. ;;; The actual positions of the info in the mc68881 FPCR and FPSR.
  24. ;;;
  25. (defconstant mc68881-fpcr-rounding-mode-byte (byte 2 4))
  26. (defconstant mc68881-fpcr-rounding-precision-byte (byte 2 6))
  27. (defconstant mc68881-fpcr-traps-byte (byte 8 8))
  28. (defconstant mc68881-fpsr-accrued-exceptions-byte (byte 5 3))
  29. (defconstant mc68881-fpsr-current-exceptions-byte (byte 8 8))
  30. (defconstant mc68881-fpsr-condition-code-byte (byte 4 24))
  31.  
  32. ;;; Amount to shift by the get the condition code, - 16.
  33. ;;;
  34. (defconstant mc68881-fpsr-condition-code-shift-16 8)
  35.  
  36. ;;; The condition code bits.
  37. ;;;
  38. (defconstant mc68881-nan-condition (ash 1 0))
  39. (defconstant mc68881-infinity-condition (ash 1 1))
  40. (defconstant mc68881-zero-condition (ash 1 2))
  41. (defconstant mc68881-negative-condition (ash 1 3))
  42.  
  43. ;;; Masks that map the extended set of exceptions implemented by the 68881 to
  44. ;;; the IEEE exceptions.  This extended format is used for the enabled traps
  45. ;;; and the current exceptions.
  46. ;;;
  47. (defconstant mc68881-invalid-exception (ash #b111 5))
  48. (defconstant mc68881-overflow-exception (ash 1 4))
  49. (defconstant mc68881-underflow-exception (ash 1 3))
  50. (defconstant mc68881-divide-zero-exception (ash 1 2))
  51. (defconstant mc68881-inexact-exception (ash #b11 0))
  52.  
  53. ;;; Encoding of float exceptions in the FLOATING-POINT-MODES result.  This is
  54. ;;; also the encoding used in the mc68881 accrued exceptions.
  55. ;;;
  56. (defconstant float-inexact-trap-bit (ash 1 0))
  57. (defconstant float-divide-by-zero-trap-bit (ash 1 1))
  58. (defconstant float-underflow-trap-bit (ash 1 2))
  59. (defconstant float-overflow-trap-bit (ash 1 3))
  60. (defconstant float-invalid-trap-bit (ash 1 4))
  61.  
  62. (defconstant float-round-to-nearest 0)
  63. (defconstant float-round-to-zero 1)
  64. (defconstant float-round-to-negative 2)
  65. (defconstant float-round-to-positive 3)
  66.  
  67. ;;; Positions of bits in the FLOATING-POINT-MODES result.
  68. ;;;
  69. (defconstant float-rounding-mode (byte 2 0))
  70. (defconstant float-sticky-bits (byte 5 2))
  71. (defconstant float-traps-byte (byte 5 7))
  72. (defconstant float-exceptions-byte (byte 5 12))
  73. (defconstant float-fast-bit 0)
  74.  
  75. ); eval-when
  76.  
  77. ;;; When compared to the 68881 documentation, the RT only uses the low 16 bits
  78. ;;; of the instruction.  Memory access is controlled in an RT specific way.
  79. ;;; See the AFPA coprocessor hardware assist operation (page B34 in volume 1.)
  80.  
  81.  
  82. ;;;; Move functions:
  83. ;;;
  84. ;;; See With-FP-Temp comment...
  85.  
  86. (define-move-function (load-single 7) (vop x y)
  87.   ((single-stack) (mc68881-single-reg))
  88.   (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset x) vm:word-bytes))
  89.   (with-fp-temp (temp)
  90.     (inst mc68881-load y lip-tn :single temp)))
  91.  
  92. (define-move-function (store-single 8) (vop x y)
  93.   ((mc68881-single-reg) (single-stack))
  94.   (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes))
  95.   (with-fp-temp (temp)
  96.     (inst mc68881-store x lip-tn :single temp)))
  97.  
  98. (define-move-function (load-double 7) (vop x y)
  99.   ((double-stack) (mc68881-double-reg))
  100.   (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset x) vm:word-bytes))
  101.   (with-fp-temp (temp)
  102.     (inst mc68881-load y lip-tn :double temp)))
  103.  
  104. (define-move-function (store-double 8) (vop x y)
  105.   ((mc68881-double-reg) (double-stack))
  106.   (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes))
  107.   (with-fp-temp (temp)
  108.     (inst mc68881-store x lip-tn :double temp)))
  109.  
  110.  
  111. ;;;; Move VOPs:
  112.  
  113. (define-vop (mc68881-move)
  114.   (:args (x :scs (mc68881-single-reg mc68881-double-reg)
  115.         :target y
  116.         :load-if (not (location= x y))))
  117.   (:results (y :scs (mc68881-single-reg mc68881-double-reg)
  118.            :load-if (not (location= x y))))
  119.   (:temporary (:sc sap-reg) temp)
  120.   (:generator 0
  121.     (unless (location= y x)
  122.       (inst mc68881-move y x temp))))
  123.  
  124. (define-move-vop mc68881-move :move
  125.   (mc68881-single-reg) (mc68881-single-reg)
  126.   (mc68881-double-reg) (mc68881-double-reg))
  127.  
  128.  
  129. (define-vop (move-to-mc68881)
  130.   (:args (x :scs (descriptor-reg)))
  131.   (:results (y :scs (mc68881-single-reg mc68881-double-reg)))
  132.   (:temporary (:sc sap-reg) temp)
  133.   (:variant-vars format data)
  134.   (:generator 7
  135.     (inst cal lip-tn x (- (* data vm:word-bytes) vm:other-pointer-type))
  136.     (inst mc68881-load y lip-tn format temp)))
  137.  
  138. (macrolet ((frob (name format data sc)
  139.          `(progn
  140.         (define-vop (,name move-to-mc68881)
  141.           (:variant ,format ,data))
  142.         (define-move-vop ,name :move (descriptor-reg) (,sc)))))
  143.   (frob move-to-mc68881-single :single vm:single-float-value-slot
  144.     mc68881-single-reg)
  145.   (frob move-to-mc68881-double :double vm:double-float-value-slot
  146.     mc68881-double-reg))
  147.  
  148.  
  149. (define-vop (move-from-mc68881)
  150.   (:args (x :scs (mc68881-single-reg mc68881-double-reg) :to :save))
  151.   (:results (y :scs (descriptor-reg)))
  152.   (:temporary (:scs (sap-reg)) ndescr)
  153.   (:temporary (:scs (word-pointer-reg)) alloc)
  154.   (:variant-vars format size type data)
  155.   (:generator 20
  156.     (with-fixed-allocation (y ndescr alloc type size)
  157.       (inst cal lip-tn y (- (* data vm:word-bytes) vm:other-pointer-type))
  158.       (inst mc68881-store x lip-tn format ndescr))))
  159.  
  160. (macrolet ((frob (name sc &rest args)
  161.          `(progn
  162.         (define-vop (,name move-from-mc68881)
  163.           (:variant ,@args))
  164.         (define-move-vop ,name :move (,sc) (descriptor-reg)))))
  165.   (frob move-from-mc68881-single mc68881-single-reg
  166.     :single vm:single-float-size vm:single-float-type
  167.     vm:single-float-value-slot)
  168.   (frob move-from-mc68881-double mc68881-double-reg
  169.     :double vm:double-float-size vm:double-float-type
  170.     vm:double-float-value-slot))
  171.  
  172. (define-vop (move-to-mc68881-argument)
  173.   (:args (x :scs (mc68881-single-reg mc68881-double-reg) :target y)
  174.      (nfp :scs (word-pointer-reg)
  175.           :load-if (not (sc-is y mc68881-single-reg mc68881-double-reg))))
  176.   (:results (y))
  177.   (:temporary (:sc sap-reg) temp)
  178.   (:variant-vars format)
  179.   (:vop-var vop)
  180.   (:generator 7
  181.     (sc-case y
  182.       ((mc68881-single-reg mc68881-double-reg)
  183.        (unless (location= y x)
  184.      (inst mc68881-move y x temp)))
  185.       ((single-stack double-stack)
  186.        (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes))
  187.        (inst mc68881-store y lip-tn format temp)))))
  188.  
  189. (macrolet ((frob (name format sc)
  190.          `(progn
  191.         (define-vop (,name move-to-mc68881-argument)
  192.           (:variant ,format))
  193.         (define-move-vop ,name :move-argument
  194.           (,sc descriptor-reg) (,sc)))))
  195.   (frob move-mc68881-single-float-argument :single mc68881-single-reg)
  196.   (frob move-mc68881-double-float-argument :double mc68881-double-reg))
  197.  
  198. (define-move-vop move-argument :move-argument
  199.   (mc68881-single-reg mc68881-double-reg) (descriptor-reg))
  200.  
  201.  
  202. ;;;; Arithmetic VOPs:
  203.  
  204. (define-vop (mc68881-op)
  205.   (:args (x) (y))
  206.   (:results (r))
  207.   (:temporary (:sc sap-reg) temp)
  208.   (:policy :fast-safe)
  209.   (:note "inline float arithmetic")
  210.   (:vop-var vop)
  211.   (:save-p :compute-only))
  212.  
  213. (macrolet ((frob (name sc ptype)
  214.          `(define-vop (,name mc68881-op)
  215.         (:args (x :scs (,sc) :target r)
  216.                (y :scs (,sc)))
  217.         (:results (r :scs (,sc) :from (:argument 0)))
  218.         (:arg-types ,ptype ,ptype)
  219.         (:result-types ,ptype)
  220.         (:variant-vars op)
  221.         (:generator 20
  222.           (unless (location= x r)
  223.             (inst mc68881-move r x temp))
  224.           (note-this-location vop :internal-error)
  225.           (inst mc68881-binop r y op temp)))))
  226.   (frob mc68881-single-float-op mc68881-single-reg mc68881-single-float)
  227.   (frob mc68881-double-float-op mc68881-double-reg mc68881-double-float))
  228.  
  229. (macrolet ((frob (op sinst sname dinst dname)
  230.          `(progn
  231.         (define-vop (,sname mc68881-single-float-op)
  232.           (:translate ,op)
  233.           (:variant ,sinst))
  234.         (define-vop (,dname mc68881-double-float-op)
  235.           (:translate ,op)
  236.           (:variant ,dinst)))))
  237.   (frob + :add +/single-float :add +/double-float)
  238.   (frob - :sub -/single-float :sub -/double-float)
  239.   (frob * :sglmul */single-float :mul */double-float)
  240.   (frob / :sgldiv //single-float :div //double-float))
  241.  
  242. (define-vop (mc68881-unop mc68881-op)
  243.   (:args (x)))
  244.  
  245. (macrolet ((frob (name sc ptype)
  246.          `(define-vop (,name mc68881-unop)
  247.         (:args (x :scs (,sc)))
  248.         (:results (r :scs (,sc)))
  249.         (:arg-types ,ptype)
  250.         (:result-types ,ptype)
  251.         (:variant-vars op)
  252.         (:generator 20
  253.           (inst mc68881-unop r x op temp)))))
  254.   (frob mc68881-single-float-unop mc68881-single-reg mc68881-single-float)
  255.   (frob mc68881-double-float-unop mc68881-double-reg mc68881-double-float))
  256.  
  257.  
  258. (macrolet ((frob (op sinst sname dinst dname)
  259.          `(progn
  260.         (define-vop (,sname mc68881-single-float-unop)
  261.           (:translate ,op)
  262.           (:variant ,sinst))
  263.         (define-vop (,dname mc68881-double-float-unop)
  264.           (:translate ,op)
  265.           (:variant ,dinst)))))
  266.   (frob abs :abs abs/single-float :abs abs/double-float)
  267.   (frob %negate :neg %negate/single-float :neg %negate/double-float))
  268.  
  269.  
  270. ;;;; Comparison:
  271.  
  272. (define-vop (mc68881-compare)
  273.   (:args (x) (y))
  274.   (:conditional)
  275.   (:info target not-p)
  276.   (:policy :fast-safe)
  277.   (:temporary (:sc sap-reg) temp)
  278.   (:temporary (:sc descriptor-reg) loc)
  279.   (:temporary (:sc unsigned-stack) loc-tn)
  280.   (:variant-vars condition)
  281.   (:note "inline float comparison")
  282.   (:vop-var vop)
  283.   (:save-p :compute-only)
  284.   (:generator 20
  285.     (let ((drop-thru (gen-label)))
  286.       (note-this-location vop :internal-error)
  287.       (if (eq condition '<)
  288.       (inst mc68881-compare y x :cmp temp)
  289.       (inst mc68881-compare x y :cmp temp))
  290.       (let ((nfp (current-nfp-tn vop)))
  291.     (inst cal loc nfp (* (tn-offset loc-tn) word-bytes)))
  292.       (inst mc68881-store-status :fpsr loc temp)
  293.       (loadw temp loc)
  294.       (ecase condition
  295.     ((< >)
  296.      (inst niuz temp temp
  297.            (ash (logior mc68881-zero-condition
  298.                 mc68881-negative-condition
  299.                 mc68881-nan-condition)
  300.             mc68881-fpsr-condition-code-shift-16)))
  301.     (eql
  302.      (inst niuz temp temp
  303.            (ash mc68881-zero-condition
  304.             mc68881-fpsr-condition-code-shift-16))
  305.      (setq not-p (not not-p))))
  306.       
  307.       (if not-p
  308.       (inst bnc :eq target)
  309.       (inst bc :eq target))
  310.       (emit-label drop-thru))))
  311.  
  312. (macrolet ((frob (name sc ptype)
  313.          `(define-vop (,name mc68881-compare)
  314.         (:args (x :scs (,sc))
  315.                (y :scs (,sc)))
  316.         (:arg-types ,ptype ,ptype))))
  317.   (frob mc68881-single-float-compare mc68881-single-reg mc68881-single-float)
  318.   (frob mc68881-double-float-compare mc68881-double-reg mc68881-double-float))
  319.  
  320. (macrolet ((frob (translate sname dname)
  321.          `(progn
  322.         (define-vop (,sname mc68881-single-float-compare)
  323.           (:translate ,translate)
  324.           (:variant ',translate))
  325.         (define-vop (,dname mc68881-double-float-compare)
  326.           (:translate ,translate)
  327.           (:variant ',translate)))))
  328.   (frob < mc68881-</single-float mc68881-</double-float)
  329.   (frob > mc68881->/single-float mc68881->/double-float)
  330.   (frob eql mc68881-eql/single-float mc68881-eql/double-float))
  331.  
  332.  
  333. ;;;; Conversion:
  334.  
  335. (macrolet ((frob (name translate to-sc to-type)
  336.          `(define-vop (,name)
  337.         (:args (x :scs (signed-reg) :target temp
  338.               :load-if (not (sc-is x signed-stack))))
  339.         (:temporary (:scs (single-stack)) temp)
  340.         (:temporary (:sc word-pointer-reg) addr)
  341.         (:temporary (:sc sap-reg) scratch)
  342.         (:results (y :scs (,to-sc)))
  343.         (:arg-types signed-num)
  344.         (:result-types ,to-type)
  345.         (:policy :fast-safe)
  346.         (:note "inline float coercion")
  347.         (:translate ,translate)
  348.         (:vop-var vop)
  349.         (:save-p :compute-only)
  350.         (:generator 20
  351.           (let ((stack-tn
  352.              (sc-case x
  353.                (signed-reg
  354.                 (storew x
  355.                     (current-nfp-tn vop)
  356.                     (* (tn-offset temp) vm:word-bytes))
  357.                 temp)
  358.                (signed-stack
  359.                 x))))
  360.             (inst cal addr (current-nfp-tn vop) 
  361.              (* (tn-offset stack-tn) vm:word-bytes))
  362.             (note-this-location vop :internal-error)
  363.             (inst mc68881-load y addr :integer scratch))))))
  364.   (frob mc68881-%single-float/signed %single-float
  365.     mc68881-single-reg mc68881-single-float)
  366.   (frob mc68881-%double-float/signed %double-float
  367.     mc68881-double-reg mc68881-double-float))
  368.  
  369. ;;; Everything is represented as extended precision, so these operations don't
  370. ;;; really do anything.  (Or, rather, whatever semantics there is, is
  371. ;;; automatically handled by the load functions.)
  372. ;;;
  373. (macrolet ((frob (name translate from-sc from-type to-sc to-type)
  374.          `(define-vop (,name mc68881-move)
  375.         (:args (x :scs (,from-sc) :target y))
  376.         (:results (y :scs (,to-sc)))
  377.         (:arg-types ,from-type)
  378.         (:result-types ,to-type)
  379.         (:policy :fast-safe)
  380.         (:note "inline float coercion")
  381.         (:translate ,translate))))
  382.   (frob mc68881-%single-float/double-float %single-float
  383.     mc68881-double-reg mc68881-double-float
  384.     mc68881-single-reg mc68881-single-float)
  385.   (frob mc68881-%double-float/single-float %double-float
  386.     mc68881-single-reg mc68881-single-float
  387.     mc68881-double-reg mc68881-double-float))
  388.  
  389. (macrolet ((frob (trans from-sc from-type inst)
  390.          `(define-vop (,(symbolicate trans "/" from-type))
  391.         (:args (x :scs (,from-sc) :target temp))
  392.         (:temporary (:from (:argument 0) :sc mc68881-single-reg) temp)
  393.         (:temporary (:sc sap-reg) scratch)
  394.         (:temporary (:scs (signed-stack)) stack-temp)
  395.         (:temporary (:sc word-pointer-reg) addr)
  396.         (:results (y :scs (signed-reg)
  397.                  :load-if (not (sc-is y signed-stack))))
  398.         (:arg-types ,from-type)
  399.         (:result-types signed-num)
  400.         (:translate ,trans)
  401.         (:policy :fast-safe)
  402.         (:note "inline float truncate")
  403.         (:vop-var vop)
  404.         (:save-p :compute-only)
  405.         (:generator 5
  406.           (note-this-location vop :internal-error)
  407.           (inst mc68881-unop temp x ,inst scratch)
  408.           (sc-case y
  409.             (signed-stack
  410.              (inst cal addr (current-nfp-tn vop)
  411.               (* (tn-offset y) vm:word-bytes))
  412.              (inst mc68881-store temp addr :integer scratch))
  413.             (signed-reg
  414.              (inst cal addr (current-nfp-tn vop)
  415.               (* (tn-offset stack-temp) vm:word-bytes))
  416.              (inst mc68881-store temp addr :integer scratch)
  417.              (loadw y (current-nfp-tn vop)
  418.                 (tn-offset stack-temp))))))))
  419.   (frob %unary-truncate mc68881-single-reg mc68881-single-float :intrz)
  420.   (frob %unary-truncate mc68881-double-reg mc68881-double-float :intrz)
  421.   (frob %unary-round mc68881-single-reg mc68881-single-float :int)
  422.   (frob %unary-round mc68881-double-reg mc68881-double-float :int))
  423.  
  424.  
  425. (define-vop (make-mc68881-single-float)
  426.   (:args (bits :scs (signed-reg) :target res
  427.            :load-if (not (sc-is bits signed-stack))))
  428.   (:results (res :scs (mc68881-single-reg)
  429.          :load-if (not (sc-is res single-stack))))
  430.   (:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp)
  431.   (:temporary (:scs (signed-stack)) stack-temp)
  432.   (:temporary (:sc sap-reg) scratch)
  433.   (:temporary (:sc word-pointer-reg) addr)
  434.   (:arg-types signed-num)
  435.   (:result-types mc68881-single-float)
  436.   (:translate make-single-float)
  437.   (:policy :fast-safe)
  438.   (:vop-var vop)
  439.   (:generator 20
  440.     (sc-case bits
  441.       (signed-reg
  442.        (sc-case res
  443.      (mc68881-single-reg
  444.       (storew bits (current-nfp-tn vop) (tn-offset stack-temp))
  445.       (inst cal addr (current-nfp-tn vop)
  446.         (* (tn-offset stack-temp) vm:word-bytes))
  447.       (inst mc68881-load res addr :single scratch))
  448.      (single-stack
  449.       (storew bits (current-nfp-tn vop) (tn-offset res)))))
  450.       (signed-stack
  451.        (sc-case res
  452.      (mc68881-single-reg
  453.       (inst cal addr (current-nfp-tn vop)
  454.         (* (tn-offset bits) vm:word-bytes))
  455.       (inst mc68881-load res addr :single scratch))
  456.      (single-stack
  457.       (unless (location= bits res)
  458.         (loadw temp (current-nfp-tn vop) (tn-offset bits))
  459.         (storew temp (current-nfp-tn vop) (tn-offset res)))))))))
  460.  
  461. (define-vop (make-mc68881-double-float)
  462.   (:args (hi-bits :scs (signed-reg))
  463.      (lo-bits :scs (unsigned-reg)))
  464.   (:arg-types signed-num unsigned-num)
  465.   (:results (res :scs (mc68881-double-reg)
  466.          :load-if (not (sc-is res double-stack))))
  467.   (:result-types mc68881-double-float)
  468.   (:temporary (:scs (double-stack)) temp)
  469.   (:temporary (:sc sap-reg :from (:eval 0)) scratch)
  470.   (:temporary (:sc word-pointer-reg :from (:eval 0)) addr)
  471.   (:translate make-double-float)
  472.   (:policy :fast-safe)
  473.   (:vop-var vop)
  474.   (:generator 25
  475.     (let ((stack-tn (sc-case res
  476.               (double-stack res)
  477.               (mc68881-double-reg temp))))
  478.       (storew hi-bits (current-nfp-tn vop) (tn-offset stack-tn))
  479.       (storew lo-bits (current-nfp-tn vop) (1+ (tn-offset stack-tn))))
  480.     (when (sc-is res mc68881-double-reg)
  481.       (inst cal addr (current-nfp-tn vop) (* (tn-offset temp) vm:word-bytes))
  482.       (inst mc68881-load res addr :double scratch))))
  483.  
  484. (define-vop (mc68881-single-float-bits)
  485.   (:args (float :scs (mc68881-single-reg)))
  486.   (:results (bits :scs (signed-reg)))
  487.   (:temporary (:scs (signed-stack)) stack-temp)
  488.   (:temporary (:sc sap-reg) scratch)
  489.   (:temporary (:sc word-pointer-reg) addr)
  490.   (:arg-types mc68881-single-float)
  491.   (:result-types signed-num)
  492.   (:translate single-float-bits)
  493.   (:policy :fast-safe)
  494.   (:vop-var vop)
  495.   (:generator 20
  496.     (inst cal addr (current-nfp-tn vop)
  497.       (* (tn-offset stack-temp) vm:word-bytes))
  498.     (inst mc68881-store float addr :single scratch)
  499.     (loadw bits (current-nfp-tn vop) (tn-offset stack-temp))))
  500.  
  501. (define-vop (mc68881-double-float-high-bits)
  502.   (:args (float :scs (mc68881-double-reg)))
  503.   (:results (bits :scs (signed-reg)))
  504.   (:temporary (:scs (double-stack)) stack-temp)
  505.   (:temporary (:sc sap-reg) scratch)
  506.   (:temporary (:sc word-pointer-reg) addr)
  507.   (:arg-types mc68881-double-float)
  508.   (:result-types signed-num)
  509.   (:translate double-float-high-bits)
  510.   (:policy :fast-safe)
  511.   (:vop-var vop)
  512.   (:variant-vars offset)
  513.   (:variant 0)
  514.   (:generator 20
  515.     (inst cal addr (current-nfp-tn vop)
  516.       (* (tn-offset stack-temp) vm:word-bytes))
  517.     (inst mc68881-store float addr :double scratch)
  518.     (loadw bits (current-nfp-tn vop) (+ (tn-offset stack-temp) offset))))
  519.  
  520. (define-vop (mc68881-double-float-low-bits mc68881-double-float-high-bits)
  521.   (:results (bits :scs (unsigned-reg)))
  522.   (:result-types unsigned-num)
  523.   (:variant 1)
  524.   (:translate double-float-low-bits))
  525.  
  526.  
  527. ;;;; Float mode hackery:
  528.  
  529. (deftype float-modes () '(unsigned-byte 32))
  530. (defknown floating-point-modes () float-modes (flushable))
  531. (defknown ((setf floating-point-modes)) (float-modes)
  532.   float-modes)
  533.  
  534. (define-vop (floating-point-modes)
  535.   (:results (res :scs (unsigned-reg)))
  536.   (:result-types unsigned-num)
  537.   (:translate floating-point-modes)
  538.   (:policy :fast-safe)
  539.   #+nil (:vop-var vop)
  540.   #+nil (:temporary (:sc unsigned-stack) temp)
  541.   (:generator 3
  542.     #+nil
  543.     (let ((nfp (current-nfp-tn vop)))
  544.       (inst stfsr nfp (* word-bytes (tn-offset temp)))
  545.       (loadw res nfp (tn-offset temp))
  546.       (inst nop))
  547.     (inst li res 0)))
  548.  
  549. (define-vop (set-floating-point-modes)
  550.   (:args (new :scs (unsigned-reg) :target res))
  551.   (:results (res :scs (unsigned-reg)))
  552.   (:arg-types unsigned-num)
  553.   (:result-types unsigned-num)
  554.   (:translate (setf floating-point-modes))
  555.   (:policy :fast-safe)
  556.   #+nil (:temporary (:sc unsigned-stack) temp)
  557.   #+nil (:vop-var vop)
  558.   (:generator 3
  559.     #+nil
  560.     (let ((nfp (current-nfp-tn vop)))
  561.       (storew new nfp (tn-offset temp))
  562.       (inst ldfsr nfp (* word-bytes (tn-offset temp)))
  563.       (move res new))
  564.     (move res new)))
  565.